home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / library.tcl < prev    next >
Encoding:
Text File  |  1998-12-20  |  26.6 KB  |  908 lines  |  [TEXT/ALFA]
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # SCCS: @(#) init.tcl 1.86 97/08/08 10:37:39
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  10. # Some additions copyright (c) 1997-1998 Vince Darley.
  11.  
  12. set errorCode ""
  13. set errorInfo ""
  14.  
  15. if {[info commands tclLog] == ""} {
  16.     proc tclLog {args} {
  17.     message [string trim [join $args ""] "\r"]
  18.     }
  19. }
  20. if {[info tclversion] >= 8.0} {
  21.     namespace eval index {}
  22.     namespace eval procs {}
  23.     # used to force some child namespaces into existence
  24.     ;proc namesp {var} {
  25.     if {[catch "uplevel global $var"]} {
  26.         set ns ""
  27.         while {[regexp "^(::)?($ns\[a-zA-Z_\]+::)" $var ns]} {
  28.         uplevel "namespace eval $ns {}"
  29.         }
  30.     }
  31.     }
  32. } else {
  33.     ;proc namesp {var} {}
  34.     rename load evaluate
  35. }
  36.  
  37. # 7.1 doesn't rename unbind in the actual application
  38. if {[info commands unBind] == ""} { rename unbind unBind }
  39.  
  40. # define compatibility procs for menu, bind, unbind
  41. if {[info commands bind] == ""} {
  42.     proc bind {args} { uplevel 1 Bind $args }
  43.     proc unbind {args} { uplevel 1 unBind $args }
  44.     proc menu {args} { 
  45.     regsub -all "\{menu " $args "\{Menu " args
  46.     uplevel 1 Menu $args 
  47.     }
  48. }
  49. namespace eval file {}
  50. # determine platform specific directory symbol
  51. regexp {Z(.)Z} [file join Z Z] "" file::separator
  52.  
  53. ## 
  54.  # -------------------------------------------------------------------------
  55.  # 
  56.  # "unknown" --
  57.  # 
  58.  #  Almost the same as standard Tcl 8 unknown.  Since we're on a Mac,
  59.  #  I removed the auto_execok flag, and for some reason had to change
  60.  #  'history change $newcmd 0' to 'history change $newcmd'
  61.  # -------------------------------------------------------------------------
  62.  ##
  63. # unknown --
  64. # This procedure is called when a Tcl command is invoked that doesn't
  65. # exist in the interpreter.  It takes the following steps to make the
  66. # command available:
  67. #
  68. #    1. See if the autoload facility can locate the command in a
  69. #       Tcl script file.  If so, load it and execute it.
  70. #    2. If the command was invoked interactively at top-level:
  71. #        (a) see if the command exists as an executable UNIX program.
  72. #        If so, "exec" the command.
  73. #        (b) see if the command requests csh-like history substitution
  74. #        in one of the common forms !!, !<number>, or ^old^new.  If
  75. #        so, emulate csh's history substitution.
  76. #        (c) see if the command is a unique abbreviation for another
  77. #        command.  If so, invoke the command.
  78. #
  79. # Arguments:
  80. # args -    A list whose elements are the words of the original
  81. #        command, including the command name.
  82. proc unknown args {
  83.     global auto_noload env unknown_pending tcl_interactive
  84.     global errorCode errorInfo
  85.     
  86.     # Save the values of errorCode and errorInfo variables, since they
  87.     # may get modified if caught errors occur below.  The variables will
  88.     # be restored just before re-executing the missing command.
  89.     
  90.     set savedErrorCode $errorCode
  91.     set savedErrorInfo $errorInfo
  92.     set name [lindex $args 0]
  93.     if {![info exists auto_noload]} {
  94.     #
  95.     # Make sure we're not trying to load the same proc twice.
  96.     #
  97.     if {[info exists unknown_pending($name)]} {
  98.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  99.     }
  100.     set unknown_pending($name) pending;
  101.     set ret [catch {auto_load $name} msg]
  102.     unset unknown_pending($name);
  103.     if {$ret != 0} {
  104.         return -code $ret -errorcode $errorCode \
  105.           "error while autoloading \"$name\": $msg"
  106.     }
  107.     if {![array size unknown_pending]} {
  108.         unset unknown_pending
  109.     }
  110.     if {$msg} {
  111.         set errorCode $savedErrorCode
  112.         set errorInfo $savedErrorInfo
  113.         set code [catch {uplevel 1 $args} msg]
  114.         if {$code ==  1} {
  115.         #
  116.         # Strip the last five lines off the error stack (they're
  117.         # from the "uplevel" command).
  118.         #
  119.         
  120.         set new [split $errorInfo \n]
  121.         set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
  122.         return -code error -errorcode $errorCode \
  123.           -errorinfo $new $msg
  124.         } else {
  125.         return -code $code $msg
  126.         }
  127.     }
  128.     }
  129.     if {([info level] == 1) && ([info script] == "") \
  130.       && [info exists tcl_interactive] && $tcl_interactive} {
  131.     set errorCode $savedErrorCode
  132.     set errorInfo $savedErrorInfo
  133.     if {$name == "!!"} {
  134.         set newcmd [history event]
  135.     } elseif {[regexp {^!(.+)$} $name dummy event]} {
  136.         set newcmd [history event $event]
  137.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  138.         set newcmd [history event -1]
  139.         catch {regsub -all -- $old $newcmd $new newcmd}
  140.     }
  141.     if {[info exists newcmd]} {
  142.         tclLog "\r" $newcmd
  143.         history change $newcmd
  144.         return [uplevel $newcmd]
  145.     }
  146.     
  147.     set ret [catch {set cmds [info commands $name*]} msg]
  148.     if {[string compare $name "::"] == 0} {
  149.         set name ""
  150.     }
  151.     if {$ret != 0} {
  152.         return -code $ret -errorcode $errorCode \
  153.           "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
  154.     }
  155.     if {[llength $cmds] == 1} {
  156.         return [uplevel [lreplace $args 0 0 $cmds]]
  157.     }
  158.     if {[llength $cmds] != 0} {
  159.         if {$name == ""} {
  160.         return -code error "empty command name \"\""
  161.         } else {
  162.         return -code error \
  163.           "ambiguous command name \"$name\": [lsort $cmds]"
  164.         }
  165.     }
  166.     }
  167.     return -code error "invalid command name \"$name\""
  168. }
  169.  
  170. ## 
  171.  # -------------------------------------------------------------------------
  172.  # 
  173.  # "auto_load" --
  174.  # 
  175.  #  I use this separate proc to be closer to the standard Tcl 8 system
  176.  #  of unknown-loading.
  177.  # -------------------------------------------------------------------------
  178.  ##
  179. proc auto_load cmd {
  180.     set f [procs::find $cmd]
  181.     if {$f != ""} {
  182.     uplevel \#0 source [list $f]
  183.     return [expr {[llength [info commands $cmd]] != 0}]
  184.     }
  185.     if {[regsub {^::} $cmd "" cmd]} {
  186.     set f [procs::find $cmd]
  187.     if {$f != ""} {
  188.         uplevel \#0 source [list $f]
  189.         return [expr {[llength [info commands $cmd]] != 0}]
  190.     }
  191.     }
  192.     # to cope with some Tcl 8 package stuff
  193.     global auto_index
  194.     if {[info exists auto_index($cmd)]} {
  195.     uplevel #0 $auto_index($cmd)
  196.     return [expr {[llength [info commands $cmd]] != 0}]
  197.     }
  198.     return 0
  199. }
  200.  
  201. # auto_mkindex:
  202. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  203. # the name of the directory in which the tclIndex file is to be placed,
  204. # and a glob pattern to use in that directory to locate all of the relevant
  205. # files.
  206. proc auto_mkindex {dir {files *.tcl}} {    
  207.     set oldDir [pwd]
  208.     cd $dir
  209.     append line "# Tcl autoload index file: each line identifies a file (nowrap)\n\n"
  210.     append line "set \"[file tail [string trim [pwd] :]]_index\" \{\n"
  211.     
  212.     set cid [scancontext create]
  213.     scanmatch $cid {^[     ]*proc[     ]} {
  214.     if {[regexp {^[     ]*proc[     ]+(("[^"]+")|(\{[^\}]+\})|([^     ]*))} $matchInfo(line) match procName]} {
  215.         append line "$procName "
  216.     }
  217.     }
  218.     
  219.     foreach file [glob $files] {
  220.     watchCursor
  221.     set f ""
  222.     append line "\{[file tail $file]\14 "
  223.     message [file tail $file]
  224.     set fid [open $file]
  225.     scanfile $cid $fid
  226.     close $fid
  227.     append line "\}\n"
  228.     }
  229.     
  230.     scancontext delete $cid
  231.     
  232.     append line "\}\n"
  233.     catch {
  234.     set f [open tclIndexx w]
  235.     puts -nonewline $f $line
  236.     close $f
  237.     }
  238.     cd $oldDir
  239.     
  240.     foreach i [info vars {*_index}] {
  241.     global $i
  242.     unset $i
  243.     }
  244. }
  245.  
  246. proc procs::find {cmd} {
  247.     global auto_path
  248.     
  249.     regsub -all {[][\$?^|*+()\{\}]} $cmd {\\&} cmd
  250.     foreach path $auto_path {
  251.     if {![file exists $path]} continue
  252.     if {![catch {file readlink $path} _path]} {
  253.         set path $_path
  254.     }
  255.     set index "[file tail $path]_index"
  256.     global $index
  257.     if {![info exists $index]} {
  258.         if {![file exists [file join $path tclIndexx]]} continue
  259.         uplevel \#0 source [list [file join $path tclIndexx]]
  260.     }
  261.     if {[regexp "\n\{(\[^\14\]+)\14\[^\n\]* \[\"\{\]?(::)?${cmd}\[\"\}\]? " [set $index] dummy file]} {
  262.         return [file join $path $file]
  263.     }
  264.     }
  265.     return ""
  266. }
  267. # this proc adds 'dummy' so 'file dirname' works the same
  268. # way for tcl7.4 and tcl8.0.
  269. proc alpha::makeAutoPath {{check_dups 1} {skipPrefs 0}} {
  270.     global HOME auto_path file::separator
  271.     if {$check_dups} {
  272.     set lcmd lunion
  273.     } else {
  274.     set lcmd lappend
  275.     }
  276.     set root [file join $HOME Tcl]
  277.     if {![catch {file readlink $root} _root]} {
  278.     set root $_root
  279.     }
  280.     
  281.     foreach dir {SystemCode Modes Menus} {
  282.     $lcmd auto_path [file join $root $dir]
  283.     foreach d [glob -nocomplain "[file join $root $dir *]${file::separator}"] {
  284.         $lcmd auto_path [file dirname "${d}dummy"]
  285.     }
  286.     }
  287.     if {!$skipPrefs} {
  288.     $lcmd auto_path [file join $root Packages]
  289.     $lcmd auto_path [file join $root UserModifications]
  290.     foreach d [glob -nocomplain "[file join $root Packages *]${file::separator}"] {
  291.         $lcmd auto_path [file dirname "${d}dummy"]
  292.     }
  293.     }
  294.     
  295. }
  296.  
  297. # Clean up temporary files:
  298. proc removeTemporaryFiles {} {
  299.     global PREFS
  300.     if {[file exists [file join $PREFS tmp]]} {
  301.     foreach f [glob -nocomplain [file join $PREFS tmp *]] {
  302.         message "removing [file tail $f]…"
  303.         file delete $f
  304.     }
  305.     }
  306.     message "all temporary files removed"
  307. }
  308. ## 
  309.  # -------------------------------------------------------------------------
  310.  # 
  311.  # "auto_reset" --
  312.  # 
  313.  #  After rebuilding indices, Tcl retains its old index information unless
  314.  #  we tell it not to.
  315.  # -------------------------------------------------------------------------
  316.  ##
  317. proc auto_reset {} {
  318.     global auto_path
  319.     foreach path $auto_path {
  320.     if {![file exists $path]} continue
  321.     set index "[file tail $path]_index"
  322.     global $index
  323.     catch {unset $index}
  324.     }
  325. }
  326.  
  327. #================================================================================
  328. # Wonderful procs from Vince Darley (darley@fas.harvard.edu).
  329. #===============================================================================
  330.  
  331. if {[info tclversion] < 8.0} {
  332. proc traceTclProc {{func ""}} {
  333.     global tclMenu
  334.     if {[llength [traceFunc status]]>2} {
  335.     catch {markMenuItem $tclMenu {traceTclProc…} off}
  336.     catch {enableMenuItem $tclMenu dumpTraces off}
  337.     if {[string length [set data [traceDump]]]} {
  338.         if {[dialog::yesno "Dump traces?"]} {
  339.         dumpTraces [string trimright [lindex [traceFunc status] 3] {,}] $data
  340.         setWinInfo dirty 0
  341.         }
  342.     }
  343.     traceFunc off
  344.     message "Tracing off."
  345.     return
  346.     }
  347.     if {$func == ""} {
  348.     set func [procs::pick 1]
  349.     }
  350.     if {![string length $func]} return
  351.     traceFunc on $func ""
  352.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  353.     catch {enableMenuItem $tclMenu dumpTraces on}
  354.     message "Tracing '$func'…"
  355. }
  356.  
  357.  
  358. proc dumpTraces {{name ""} {data ""}} {
  359.     if {![string length $name]} {
  360.     set name [string trimright [lindex [traceFunc status] 3] {,}]
  361.     }
  362.     if {![string length $data]} {
  363.     set data [traceDump]
  364.     }
  365.     
  366.     if {![string length $data]} {
  367.     message "Trace buffer empty"
  368.     } else {
  369.     regsub -all {:} $name {.} name
  370.     new -n "* Trace '$name' *" -m Tcl
  371.     insertText $data
  372.     winReadOnly
  373.     }
  374. }
  375. proc procs::traceProc {func} {
  376.     global tclMenu
  377.     # if we're tracing already then clear it
  378.     if {[llength [traceFunc status]]>2} { traceTclProc }
  379.     traceFunc on $func ""
  380.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  381.     catch {enableMenuItem $tclMenu dumpTraces on}
  382.     message "Tracing '$func'…"
  383. }
  384.  
  385. proc procs::pick {{try_sel 0}} {
  386.     if {$try_sel && [llength [winNames]] && [string length [set sel [getSelect]]]} {
  387.     if {[info procs $sel] == "$sel"} {
  388.         return $sel
  389.     } else {
  390.         return [listpick -L $sel -p {Func Name:} [lsort -ignore [info procs]]]
  391.     }
  392.     } else {
  393.     return [listpick -p {Func Name:} [lsort -ignore [info procs]]]
  394.     }
  395. }
  396.  
  397. } else {
  398. proc procs::traceProc {func} {
  399.     uplevel traceTclProc $func
  400. }
  401.  
  402. ## 
  403.  # -------------------------------------------------------------------------
  404.  # 
  405.  # "procs::pick" --
  406.  # 
  407.  #  Bug to be fixed:
  408.  #  only procs in top level namespace are returned by [info procs]
  409.  #  Should probably implement a hierarchial choice process.
  410.  # -------------------------------------------------------------------------
  411.  ##
  412. proc procs::pick {{try_sel 0}} {
  413.     if {$try_sel && [llength [winNames]] && [string length [set sel [getSelect]]]} {
  414.     if {[llength [uplevel \#0 [list info commands $sel]]] && ![catch {info args $sel}]} {
  415.         return $sel
  416.     } else {
  417.         return [listpick -L $sel -p {Func Name:} [lsort -ignore [uplevel \#0 info procs]]]
  418.     }
  419.     } else {
  420.     return [listpick -p {Func Name:} [lsort -ignore [uplevel \#0 info procs]]]
  421.     }
  422. }
  423.  
  424. ## 
  425.  # -------------------------------------------------------------------------
  426.  # 
  427.  # "traceTclProc" --
  428.  # 
  429.  #  Trace and dump still need a little work under Alpha 8.0.  Notice that
  430.  #  traces are stored in a file, not in memory as in previous versions
  431.  #  of Alpha.
  432.  # -------------------------------------------------------------------------
  433.  ##
  434. proc traceTclProc {{func ""}} {
  435.     global tclMenu alpha::tracingProc alpha::tracingChannel PREFS
  436.     if {[cmdtrace depth] > 0} {
  437.     catch {markMenuItem $tclMenu {traceTclProc…} off}
  438.     catch {enableMenuItem $tclMenu dumpTraces off}
  439.     catch {
  440.         cmdtrace off
  441.         close $alpha::tracingChannel
  442.         set alpha::tracingChannel ""
  443.     }
  444.     if {[file exists [file join $PREFS tmp traceDump]]} {
  445.         dumpTraces "" "" 1
  446.         file delete [file join $PREFS tmp traceDump]
  447.     }
  448.     message "Tracing off."
  449.     if {$func == ""} {return}
  450.     }
  451.     if {$func == ""} {
  452.     set func [procs::pick 1]
  453.     }
  454.     if {![string length $func]} return
  455.     if {![file exists [file join $PREFS tmp]]} {
  456.     file mkdir [file join $PREFS tmp]
  457.     }
  458.     set alpha::tracingChannel [open [file join $PREFS tmp traceDump] w]
  459.     cmdtrace on $alpha::tracingChannel inside $func
  460.     set alpha::tracingProc $func
  461.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  462.     catch {enableMenuItem $tclMenu dumpTraces on}
  463.     message "Tracing '$func'…"
  464. }
  465.  
  466.  
  467. proc dumpTraces {{name ""} {data ""} {ask 0}} {
  468.     global alpha::tracingProc alpha::tracingChannel PREFS
  469.     if {![string length $name]} {
  470.     set name $alpha::tracingProc
  471.     }
  472.     if {![string length $data]} {
  473.     set data [file::readAll [file join $PREFS tmp traceDump]]
  474.     if {$alpha::tracingChannel != ""} {
  475.         close $alpha::tracingChannel
  476.         file delete [file join $PREFS tmp traceDump]
  477.         set alpha::tracingChannel [open [file join $PREFS tmp traceDump] w]
  478.         cmdtrace configure $alpha::tracingChannel
  479.     }
  480.     }
  481.     
  482.     if {![string length $data]} {
  483.     message "Trace buffer empty"
  484.     } else {
  485.     if {$ask} {
  486.         if {![dialog::yesno "Dump traces?"]} {return}
  487.     }
  488.     new -n "* Trace '$name' *" -m Tcl
  489.     insertText $data
  490.     winReadOnly
  491.     }
  492. }
  493.  
  494. }
  495.  
  496.  
  497. proc rebuildTclIndices {} {
  498.     global auto_path
  499.     set d [pwd]
  500.     foreach dir $auto_path {
  501.     # in case auto_path contains relative directories (bad idea)
  502.     cd
  503.     # if directory exists
  504.     if { ![catch { cd $dir } ] } {
  505.         # if there are any files
  506.         if { ![catch { glob *.*tcl } ] } {
  507.         message "Building [file tail $dir] index…"                
  508.         # use 'catch' also in case directory is write-protected
  509.         catch { auto_mkindex : *.*tcl }
  510.         }
  511.     }
  512.     }
  513.     message ""
  514.     cd $d
  515.     # make alpha forget its old information so the new stuff is loaded
  516.     # when required.
  517.     catch {auto_reset}
  518. }
  519.  
  520. set alpha::rebuilding 0
  521.  
  522. proc alpha::rebuildPackageIndices {} {
  523.     alpha::makeIndices
  524.     message "Indices and package menu rebuilt."
  525. }
  526.  
  527. proc alpha::makeIndices {} {
  528.     # add all new directories to the auto_path
  529.     alpha::makeAutoPath
  530.     # ensure count is correctly set - otherwise we'd probably have to
  531.     # rebuild next time we started up.
  532.     alpha::rectifyPackageCount
  533.     set types {index::feature index::mode index::uninstall  index::maintainer index::help index::disable}
  534.     global pkg_file HOME alpha::rebuilding alpha::version file::separator \
  535.       index::oldmode alpha::tclversion
  536.     eval global $types
  537.     # store old mode information so we can check what changed
  538.     catch {cache::read index::mode}
  539.     catch {array set index::oldmode [array get index::mode]}
  540.     
  541.     catch {eval cache::delete $types}
  542.     foreach type $types {
  543.     catch {unset $type}
  544.     }
  545.     foreach dir [list SystemCode Modes Menus Packages] {
  546.     lappend dirs "[file join ${HOME} Tcl ${dir}]${file::separator}"
  547.     eval lappend dirs [glob -nocomplain "[file join ${HOME} Tcl ${dir} *]${file::separator}"]
  548.     }
  549.     set alpha::rebuilding 1
  550.     # provide the 'Alpha' and 'AlphaTcl' packages
  551.     ;alpha::extension Alpha ${alpha::version} {} help {file "Alpha Manual"}
  552.     ;alpha::extension AlphaTcl ${alpha::tclversion} {} help {file "Extending Alpha"}
  553.     # declare 2 different scan contexts:
  554.     set cid_scan [scancontext create]
  555.     scanmatch $cid_scan  "^\[ \t\]*alpha::(menu|mode|extension|feature|package\[ \t\]+(uninstall|disable|maintainer|help))" {
  556.     incr rebuild_cmd_count 1
  557.     }
  558.     scanmatch $cid_scan "^\[ \t\]*newPref\[ \t\]" {
  559.     if {[incr numprefs] == 1} {
  560.         set newpref_start $matchInfo(offset)
  561.     }
  562.     }
  563.     set cid_help [scancontext create]
  564.     scanmatch $cid_help "^\[ \t\]*#" {
  565.     if {[expr {$linenum +1}] != $matchInfo(linenum)} { set hhelp "" }
  566.     append hhelp [string trimleft $matchInfo(line) " \t#"] " "
  567.     set linenum $matchInfo(linenum)
  568.     }
  569.     scanmatch $cid_help "^\[ \t\]*newPref\[ \t\]" {
  570.     if {[expr {$linenum +1}] == $matchInfo(linenum)} {
  571.         if {$hhelp != ""} {
  572.         set pkg [lindex $matchInfo(line) 4]
  573.         # allow comment to over-ride the mode/package
  574.         regexp "^\\((\\w+)\\)\[ \t\]*(.*)\$" $hhelp "" pkg hhelp
  575.         if {$pkg == "" || $pkg == "global"} {
  576.             set prefshelp([lindex $matchInfo(line) 2]) $hhelp
  577.         } else {
  578.             set prefshelp($pkg,[lindex $matchInfo(line) 2]) $hhelp
  579.         }
  580.         }
  581.     }
  582.     set hhelp ""
  583.     if {[incr numprefs -1] == 0} {
  584.         error "done"
  585.     }
  586.     }
  587.     
  588.     global rebuild_cmd_count
  589.     foreach d $dirs {
  590.     foreach f [glob -nocomplain "${d}*.tcl"] {
  591.         if {![catch {open $f} fid]} {
  592.         message "scanning [file tail $f]…"
  593.         set numprefs 0
  594.         set rebuild_cmd_count 0
  595.         # check for 'newPref' or 'alpha::package' statements
  596.         scanfile $cid_scan $fid
  597.         if {$numprefs > 0} {
  598.             message "scanning [file tail $f]…($numprefs prefs)"
  599.             incr newpref_start -240
  600.             seek $fid [expr {$newpref_start > 0 ? $newpref_start : 0}]
  601.             set linenum -2
  602.             set hhelp ""
  603.             catch [list scanfile $cid_help $fid]
  604.         }
  605.         close $fid
  606.         if {$rebuild_cmd_count > 0} {
  607.             message "scanning [file tail $f] for packages"
  608.             set pkg_file $f
  609.             if {[catch {uplevel \#0 [list source $f]} res] != 11} {
  610.             if {[askyesno "Had a problem extracting package information from [file tail $f].  View error?"] == "yes"} {
  611.                 alertnote [string range $res 0 240]
  612.             }
  613.             }
  614.         }
  615.         }
  616.     }
  617.     }
  618.     catch {unset rebuild_cmd_count}
  619.     set alpha::rebuilding 0
  620.     
  621.     scancontext delete $cid_scan
  622.     scancontext delete $cid_help
  623.     cache::create index::prefshelp variable prefshelp
  624.     
  625.     foreach type $types {
  626.     cache::add $type "variable" $type
  627.     if {$type != "index::feature"} { catch {unset $type} }
  628.     }
  629.     catch {unset index::oldmode}
  630.     catch {unset pkg_file}
  631.     #foreach n [array names index::feature] {}
  632.     global alpha::requirements
  633.     if {[info exists alpha::requirements]} {
  634.     foreach itm ${alpha::requirements} {
  635.         set m [lindex $itm 0]
  636.         set req [lindex $itm 1]
  637.         if {[catch {package::versionCheck [lindex $req 0] [lindex $req 2]} err]} {
  638.         alertnote "$m mode requirements failure: $err  You should upgrade that package."
  639.         }
  640.     }
  641.     }
  642.     
  643.     message "Package index rebuilt."
  644. }
  645.  
  646. # 'exit' kills Alpha without allowing it to save etc.
  647. # 'quit' is therefore more mac-like
  648. rename exit ""
  649. proc exit {} {quit}
  650.  
  651. proc alpha::reportError {string} {
  652.     global reportErrors
  653.     if {$reportErrors} {
  654.     alertnote [string range $string 0 200]
  655.     } else {
  656.     global alpha::errorLog
  657.     append alpha::errorLog $string
  658.     }
  659. }
  660.  
  661. proc userMessage {{alerts 1} {message ""}} {
  662.     if {$alerts} {
  663.     alertnote $message
  664.     } else {
  665.     message $message
  666.     }
  667. }
  668.  
  669. proc alpha::errorAlert {text} {
  670.     alertnote $text
  671.     error $text
  672. }
  673.  
  674. namespace eval flag {}
  675.  
  676. # ALWAYS USE THIS PROC
  677. proc flag::addType {type} {
  678.     global flag::types
  679.     if {[lsearch -exact ${flag::types} $type] == -1} {
  680.     lappend flag::types $type
  681.     }
  682. }
  683.  
  684. # NEVER MESS WITH THIS VARIABLE DIRECTLY
  685. set flag::types [list "flag" "variable" "binding" "menubinding" "file" "io-file"]
  686. # Note: other types are triggered by vars ending in 'Colour', 'Color',
  687. # 'Folder', 'Path', 'Mode', 'Sig', or 'SearchPath'
  688.  
  689. ## 
  690.  # -------------------------------------------------------------------------
  691.  # 
  692.  # "newPref" --
  693.  # 
  694.  #  Define a new preference variable/flag.  You can call this procedure
  695.  #  either with multiple arguments or with a single list of all the
  696.  #  arguments.  So 'newPref flag Hey ...' or 'newPref {flag Hey ...}'
  697.  #  are both fine.
  698.  #  
  699.  #  'type' is one of:
  700.  #    'flag' (on/off only), 'variable' (anything), 'binding' (key-combo)
  701.  #    'menubinding' (key-combo which works in a menu), 'file' (input only),
  702.  #    'io-file' (either input or output).  Variables whose name ends in
  703.  #    Sig, Folder, Path, Mode, Colour, Color or SearchPath (case matters here) 
  704.  #    are treated differently, but are still considered of type 'variable'.
  705.  #    For convenience this proc will map types sig, folder, color, ...
  706.  #    into 'variable' for you, _if_ the variable ends with the correct
  707.  #    string.
  708.  #    
  709.  #  'name' is the var name, 
  710.  #  
  711.  #  'val' is its default value (which will be ignored if the variable
  712.  #  already has a value)
  713.  #  
  714.  #  'pkg' is either 'global' to mean a global preference, or the name 
  715.  #  of the mode or package (no spaces) for which this is a preference.
  716.  #  
  717.  #  'pname' is a procedure to call if this preference is changed by
  718.  #  the user (no need to setup a trace).  This proc is only called
  719.  #  for changes made through prefs dialogs or prefs menus created by
  720.  #  Alpha's core procs.  Other changes are not traced.
  721.  #  
  722.  #  Depending on the previous values, there are two optional arguments
  723.  #  with the following uses:
  724.  #  
  725.  #  TYPE:
  726.  #  
  727.  #  variable:
  728.  #  
  729.  #  'options' is a list of items from which this preference takes a single
  730.  #  item.
  731.  #  'subopt' is any of 'item', 'index', 'varitem' or 'varindex' or 'array', where
  732.  #  'item' indicates the pref is simply an item from the given list
  733.  #  of items, 'index' indicates it is an index into that list, and
  734.  #  'var*' indicates 'items' is in fact the name of a global variable
  735.  #  which contains the list. 'array' means take one of the values from an array.
  736.  #  If no value is given, 'item' is the default
  737.  #  
  738.  #  binding:
  739.  #  
  740.  #  'options' is the name of a proc to which this item should be bound.
  741.  #  If options = '1', then we Bind to the proc with the same name as
  742.  #  this variable.  Otherwise we do not perform automatic bindings.
  743.  #  
  744.  #  'subopt' indicates whether the binding is mode-specific or global.
  745.  #  It should either be 'global' or the name of a mode.  If not given,
  746.  #  it defaults to 'global' for all non-modes, and to mode-specific for
  747.  #  all packages.  (Alpha tests if something is a mode by the existence
  748.  #  of mode::features($mode))
  749.  # -------------------------------------------------------------------------
  750.  ##
  751. proc newPref {vtype {name {}} {val 0} {pkg "global"} {pname ""} {options ""} {subopt ""}} {
  752.     if {$name == {}} { uplevel 1 newPref $vtype}
  753.     
  754.     global allFlags allVars tclvars modeVars flag::procs \
  755.       flag::type flag::types
  756.     # 'link' means link this variable with Alpha's internals.
  757.     if {[regexp {^link(.*)$} $vtype "" vtype]} {
  758.     linkVar $name
  759.     # linked variables over-ride differently to normal preferences.
  760.     if {$val != ""} { global $name ; set $name $val }
  761.     }
  762.     set bad 1
  763.     foreach ty ${flag::types} {
  764.     if {[string first $vtype $ty] == 0} {
  765.         set vtype $ty
  766.         set bad 0
  767.         break
  768.     }
  769.     }
  770.     if {$bad} {
  771.     foreach ty {SearchPath Folder Path Mode Colour Color Sig} {
  772.         if {[string first $vtype [string tolower $ty]] == 0} {
  773.         if {[regexp "${ty}\$" $name]} {
  774.             set vtype variable
  775.             set bad 0
  776.             break
  777.         } else {
  778.             error "Type '$vtype' requires the variable's name to end in '$ty'"
  779.         }
  780.         }
  781.     }
  782.     if {$bad} {error "Unknown type '$vtype' in call to newPref"}
  783.     }
  784.     if {$pkg == "global"} {
  785.     switch -- $vtype {
  786.         "flag" {
  787.         lappend allFlags $name
  788.         }
  789.         "variable" {
  790.         lappend allVars $name
  791.         }
  792.         default {
  793.         set flag::type($name) $vtype
  794.         lappend allVars $name
  795.         }
  796.     }
  797.     
  798.     global $name
  799.     lunion tclvars $name
  800.     if {![info exists $name]} {set $name $val} else { set val [set $name] }
  801.     } else {
  802.     global ${pkg}modeVars
  803.     lunion modeVars $name
  804.     
  805.     if {![info exists ${pkg}modeVars($name)]} {
  806.         set ${pkg}modeVars($name) $val
  807.     } else {
  808.         set val [set ${pkg}modeVars($name)]
  809.     }
  810.     switch -- $vtype {
  811.         "flag" {
  812.         lunion allFlags $name
  813.         }
  814.         "variable" {
  815.         lappend allVars $name
  816.         }
  817.         default {
  818.         set flag::type($name) $vtype
  819.         lappend allVars $name
  820.         }
  821.     }
  822.     }
  823.     # handle 'options'
  824.     if {$options != ""} {
  825.     switch -- $vtype {
  826.         "variable" {
  827.         global flag::list
  828.         if {$subopt == ""} { set subopt "item" }
  829.         if {[lsearch -exact "array item index varitem varindex" $subopt] == -1} {
  830.             error "Unknown list element type '$subopt' in call to newPref."
  831.         }
  832.         set flag::list($name) [list $subopt $options]
  833.         }
  834.         "binding" {
  835.         global flag::binding mode::features
  836.         if {[info exists mode::features($pkg)]} {
  837.             if {$subopt == ""} { 
  838.             set subopt $pkg
  839.             } else {
  840.             if {$subopt == "global"} { set subopt "" }
  841.             }
  842.         } 
  843.         set flag::binding($name) [list $subopt $options]
  844.         if {$options == 1} { set options $name }
  845.         catch "Bind [keys::toBind $val] [list $options] $subopt"
  846.         }
  847.     }
  848.     }
  849.     # register the 'modify' proc
  850.     if {[string length $pname]} {
  851.     set flag::procs($name) $pname
  852.     }
  853. }
  854.  
  855. ## 
  856.  # -------------------------------------------------------------------------
  857.  # 
  858.  # "alpha::rectifyPackageCount" --
  859.  # 
  860.  #  Returns 1 if count has changed
  861.  # -------------------------------------------------------------------------
  862.  ##
  863. proc alpha::rectifyPackageCount {} {
  864.     global HOME file::separator
  865.     # check things haven't changed
  866.     foreach d {Modes Menus Packages} {
  867.     lappend count [llength [glob -nocomplain [file join ${HOME} Tcl ${d} "*\{.tcl,${file::separator}\}"]]]
  868.     }
  869.     if {![cache::exists index::count[join $count -]]} {
  870.     cache::deletePat index::count*
  871.     cache::create index::count[join $count -]
  872.     return 1
  873.     } else {
  874.     return 0
  875.     }
  876. }
  877.  
  878. proc alpha::checkConfiguration {} {
  879.     global alpha::version
  880.     if {![cache::exists index::feature] || (![cache::exists index::mode]) \
  881.       || ([alpha::package versions Alpha] != ${alpha::version})} {
  882.     set rebuild 1
  883.     # If there's no package information stored at all, or if Alpha's
  884.     # version number has changed, zap the cache.  This may not be
  885.     # required, but is safer since core-code changes may modify the
  886.     # form of the cache, or change the format of cached menus etc.
  887.     global PREFS
  888.     if {[cache::exists configuration]} {
  889.         # in case we crashed or some other weirdness
  890.         catch {file delete [file join ${PREFS} configuration]}
  891.         # now backup the configuration file
  892.         file rename [file join ${PREFS} Cache configuration] \
  893.           [file join ${PREFS} configuration]
  894.         rm -r [file join ${PREFS} Cache]
  895.         file mkdir [file join ${PREFS} Cache]
  896.         file rename [file join ${PREFS} configuration] \
  897.           [file join ${PREFS} Cache configuration]
  898.     } else {
  899.         rm -r [file join ${PREFS} Cache]
  900.     }
  901.     } else {
  902.     set rebuild [alpha::rectifyPackageCount]
  903.     }
  904.     return $rebuild
  905. }
  906.  
  907.  
  908.